home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / files_extra < prev    next >
Encoding:
Text File  |  1996-01-19  |  5.7 KB  |  177 lines

  1. \ additional file-oriented words to load in with 'sys'...
  2.  
  3. \ mod: 00001 22-jul-89 mdh fixed READLINE, had problems if file didn't
  4. \                          end in EOL (returned wrong datalength)
  5.  
  6. : fread?  ( file addr cnt -- actual , quit and close file if error on read )
  7.   fread ferror @
  8.   IF  cr ." Error on file read!"   quit
  9.   THEN  ;
  10.  
  11. : fseek?  ( file mode offset -- prev-pos, QUITs if seek error )
  12.   fseek dup -1 =
  13.   IF   cr ." Error on file seek!" quit
  14.   THEN  ;
  15.  
  16. : F@,? ( file -- n1 , fetch next word from file, fquit if error occurs )
  17.   >r   0 0  sp@ r> swap 4 fread? 2drop
  18. ;
  19.  
  20. : F@, ( file -- n1 , fetch next word from file, calling pgm should chk FERROR )
  21.   >r   0 0  sp@ r> swap 4 fread 0=  IF  true ferror !  then  drop
  22. ;
  23.  
  24.  
  25. \ after >DOS has loaded it, use this to append another string to dos-buffer...
  26. : +DOS  ( adr cnt -- )
  27.   dup >r      ( save cnt -- )
  28.   dosstring 2+  ( adr cnt dos -- )
  29.   BEGIN  dup c@
  30.   WHILE  1+
  31.   REPEAT ( adr cnt dos+ -- )
  32.   swap 2dup + >r   ( save end addr )  ( fr to cnt -- )
  33.   move  0 r> c!   ( null-terminate it!)
  34.   dosstring 1+ dup c@ r> + swap c!   ( inc the text forth cnt )
  35. ;
  36.  
  37. \ read line-oriented words.................................................
  38.  
  39. $ 0a constant eol
  40. variable line-start
  41. variable full-linelen
  42. variable over-start
  43. variable over-len
  44.  
  45. \ linesfill ( file Vblkaddr cnt -- #filled ) with many chars (lines) as possible, 
  46. \ to a line boundary, return #chars filled...
  47. : linesfillv  ( file vblkaddr cnt -- #chars )
  48.   rot >r  ( -- buff cnt )  2dup over-len @
  49.   IF
  50. \ cr ." moving down: " over-start @ over-len @ dup .hex dump
  51.      ( -- buf cnt buf cnt )  over-start @  2 pick  over-len @ move
  52.      over-len @ -   swap  over-len @ + swap
  53.   THEN
  54.   ( -- buf cnt buf' cnt' )  r@ -rot fread   over-len @ +  dup -1 =
  55.   over-len off
  56.   IF   drop 0
  57.   THEN        ( vbaddr cnt #read -- )
  58.   dup  3 pick freebytea ! ( vbadr cnt #read -- ) -dup
  59.   IF   ( something was read in... )
  60.        over =  ( vbadr cnt flag -- )
  61.        IF   2dup + 1- c@  eol -  ( vbadr cnt flag -- )
  62.             IF   2dup + 0 swap  ( vbadr cnt 0 lastadr -- )
  63.                  3 pick  freebyte 0
  64.                  ( vbadr cnt   0  lastcharadr  #chars 0 -- )
  65.                  DO   1- dup c@  eol =  ?leave
  66.                       swap 1+ swap
  67.                  LOOP ( vbadr cnt #back eoladr -- )
  68.                  \
  69.                  \ no EOL at all?
  70.                  dup 4 pick =
  71.                  IF
  72.                     2drop
  73.                  ELSE
  74.                     1+ over-start !  dup over-len !
  75.                     ( vbadr cnt -#back -- )  negate 2 pick  freebytea +!
  76.                  THEN
  77.             THEN
  78.        THEN
  79.   THEN ( vbadr cnt -- )  drop  freebyte   rdrop
  80. ;
  81.  
  82. : readline  ( file var-adr addr maxlen -- addr actuallen / adr -1 if at eof )
  83.   >r >r     bufferadr dup
  84.   freebyte  dup 0=     ( file vbuff freebyte flag -- )  dup
  85.   IF
  86.      over-len off
  87.   THEN  ( file vbuff freebyte flag -- )
  88.   swap  line-start @ <=  or    ( file vbuff flag -- )
  89.   IF   ( buffer is empty or has already been read )
  90.        line-start off    ( file vbuff -- )
  91.        2dup virtbuffsize  linesfillv over  freebytea !  ( file vbuff -- )
  92.   THEN r> r>
  93.   ( file vbuff adr max -- )  2 pick freebyte line-start @ - 0 max  -dup
  94.   IF
  95.        \ line-st is below filled data, so something left to read
  96.        ( file vbuff addr maxlen #left -- )
  97.        \
  98.        >r  2 pick line-start @ + ( file vbuff addr maxlen 1stchar -- )
  99.        r@ 1- swap   r> 0
  100.        DO
  101.           ( file vbuff addr maxlen #ixlastchar 1stchar -- )
  102.           dup i + c@ EOL =  \ this char an EOL?
  103.           IF
  104.              i LEAVE
  105.           ELSE
  106.              \ 2 pick  i <=      \ this char at dest size limit?
  107.              \ 2 pick  i =  OR   \ is this the index of the last char?
  108.              over  i <=     \ is this the index of the last char?
  109.              IF
  110.                  \ we have gotten to tthe end of the buffer, no eol!
  111.                 i 1+ LEAVE  \ return length, include this char
  112.              THEN
  113.           THEN
  114.        LOOP
  115.        dup full-linelen !
  116.        ( file vbuff addr maxlen #inbuff 1stchar #chars-parsed -- )
  117.        rot drop  dswap  ( file vbuff 1stchar #chars-parsed addr maxlen --) 
  118.        rot min    ( file vbuff lineadr adr len -- )
  119.        2dup +  4 pick virtbuffsize + =  3 pick 2 pick + c@ eol -  or 0=
  120.        over swap
  121.        IF
  122.           1+
  123.        THEN
  124.        line-start +!
  125.        2dup >r >r 1+ move r> r>   ( file vbuff addr actuallen -- )
  126.   ELSE drop -1
  127.   THEN dswap 2drop
  128. ;
  129.  
  130. turnkeying? NOT .IF
  131. \ this word tests the 'read line' function...
  132. : typefile   ( -- , eats name )
  133.   fopen -dup
  134.   if   dup markfclose  tempfile !    \ mark file for auto-close
  135.        tempbuff openFV ( adr -- )    \ allocate virtual buffer
  136.        markfreeblock   ( -- )        \ mark for auto free-ing by QUIT
  137.        MEMF_CLEAR 512 allocblock? dup >r
  138.        markfreeblock
  139.      \
  140.        BEGIN  tempfile @  tempbuff  r@ 512  readline dup 0< 0=
  141.        WHILE  2 x>r  ?pause  2 xr>  cr type
  142.        REPEAT 2drop
  143.      \
  144.        r> dup unmarkfreeblock freeblock
  145.        tempbuff @ unmarkfreeblock    \ don't auto-free, I will
  146.        tempbuff closefvread          \ unallocate the buffer
  147.        tempfile @ dup unmarkfclose   \ don't auto-close, I will
  148.        fclose
  149.   else cr ." Can't open "  dosstring 1+ count type  quit
  150.   then cr
  151. ;
  152. .THEN
  153.  
  154. $ 3ee constant MODE_NEWFILE        $ 3ed constant MODE_OLDFILE
  155.    -2 constant ACCESS_READ            -1 constant ACCESS_WRITE
  156.  
  157. : old  mode_oldfile filemode !  ;
  158.  
  159. USER FHOLDER  ( hold characters for I/O )
  160.  
  161. : FTYPE  ( fileptr addr count -- , write to file )
  162.     fwrite 0< ?ABORT" FTYPE write error!"
  163. ;
  164.  
  165. : FEMIT  ( fileptr char -- , write character to file )
  166.     fholder c!
  167.     fholder 1 ftype
  168. ;
  169.  
  170. -1 constant EOF
  171. : FKEY  ( fileptr -- char , get character from file , EOF if at end)
  172.     fholder 1 fread 0=
  173.     IF EOF
  174.     ELSE fholder c@
  175.     THEN
  176. ;
  177.